Prova 2 - Aprendizagem de Máquina

Questão 1:

Crie um problema de regressão simulado em que a variável target (variável resposta) depende de 5 variáveis preditoras, porém, a base de dados, com 5 mil observações possui outras 15 features que não são relevantes para a predição. A variável target deve ser gerada a partir de uma função linear das variáveis preditoras, em que você poderá definir os pesos dessas 5 primeiras e as outras 15 restantes deverão ter peso zero. Ajuste a regressão Lasso e Ridge usando 10-fold cross-validation e avalie o risco preditivo dos modelos. Quais os valores estimados dos coeficientes e qual modelo você escolheria para fazer previsões? Qual dos modelos gerou um vetor esparso dos coeficientes estimados?

Resposta:

rm(list = ls())

# Carregando pacotes 
library(tidyverse)

── Attaching core tidyverse packages ──────────────────────── tidyverse 2.0.0 ──
✔ dplyr     1.1.4     ✔ readr     2.1.5
✔ forcats   1.0.0     ✔ stringr   1.5.1
✔ ggplot2   3.5.1     ✔ tibble    3.2.1
✔ lubridate 1.9.3     ✔ tidyr     1.3.1
✔ purrr     1.0.2     
── Conflicts ────────────────────────────────────────── tidyverse_conflicts() ──
✖ dplyr::filter() masks stats::filter()
✖ dplyr::lag()    masks stats::lag()
ℹ Use the conflicted package (<http://conflicted.r-lib.org/>) to force all conflicts to become errors

library(tidymodels)

── Attaching packages ────────────────────────────────────── tidymodels 1.2.0 ──
✔ broom        1.0.6     ✔ rsample      1.2.1
✔ dials        1.3.0     ✔ tune         1.2.1
✔ infer        1.0.7     ✔ workflows    1.1.4
✔ modeldata    1.4.0     ✔ workflowsets 1.1.0
✔ parsnip      1.2.1     ✔ yardstick    1.3.1
✔ recipes      1.1.0     
── Conflicts ───────────────────────────────────────── tidymodels_conflicts() ──
✖ scales::discard() masks purrr::discard()
✖ dplyr::filter()   masks stats::filter()
✖ recipes::fixed()  masks stringr::fixed()
✖ dplyr::lag()      masks stats::lag()
✖ yardstick::spec() masks readr::spec()
✖ recipes::step()   masks stats::step()
• Use suppressPackageStartupMessages() to eliminate package startup messages

library(tibble)
library(purrr)
library(ggplot2)
library(patchwork)
library(workflowsets)
library(yardstick)
library(glmnet)

Carregando pacotes exigidos: Matrix

Anexando pacote: 'Matrix'

Os seguintes objetos são mascarados por 'package:tidyr':

    expand, pack, unpack

Loaded glmnet 4.1-8

# Dando preferencias as funcoes do tidymodels 
tidymodels::tidymodels_prefer()

# Setando a semente 
set.seed(0)

# Função para gerar os dados 
gerando_dados <- function(n = 5000L){
  regressao <- function(i){
    x <- rnorm(n = 5000L, 0, 1)
    target <- 7*x[1L] - 5*x[2L] + 2*x[3L] + 4*x[4L] + 9*x[5L] + rnorm(1L, 0, 0.5)
    tibble(
      y = target,
      x1 = x[1L],
      x2 = x[2L],
      x3 = x[3L],
      x4 = x[4L],
      x5 = x[5L]
    )
  }
  dados <- purrr::map(.x = 1L:n, .f = regressao) %>% 
    purrr::list_rbind()
  
  parte_esparsa <- matrix(0, n, 15)
  
  dados <- cbind(dados, parte_esparsa)
  colnames(dados) <- c("y", paste0("x", 1L:20L))
  tibble::as_tibble(dados)
}

dados <- gerando_dados()

# Realizando o hold-out 
dados_split <- rsample::initial_split(dados, prop = 0.8, strata = "y")
treino <- rsample::training(dados_split)
teste <- rsample::testing(dados_split)

# Setando o modelo (set engine) 
modelo_ridge <- 
  parsnip::linear_reg(penalty = tune::tune(), mixture = 0) %>% 
  parsnip::set_mode("regression") %>% 
  parsnip::set_engine("glmnet")

modelo_lasso <- 
  parsnip::linear_reg(penalty = tune::tune(), mixture = 1) %>% 
  parsnip::set_mode("regression") %>% 
  parsnip::set_engine("glmnet")

# Criando workflows 
all_wf <- 
  workflowsets::workflow_set(
    preproc = list(y ~ .),
    models = list(ridge = modelo_ridge, lasso = modelo_lasso), 
    cross = TRUE
  )

# Validação cruzada 
set.seed(0)
cv <- rsample::vfold_cv(treino, v = 10L)

# Setando a métrica 
metrica <- yardstick::metric_set(rmse)

# Tunagem dos hiperparâmetros 
tunagem <- 
  all_wf %>% 
  workflowsets::workflow_map(
    seed = 0, 
    verbose = TRUE,
    resamples = cv,
    grid = 50,
    metrics = metrica
  )

i 1 of 2 tuning:     formula_ridge
✔ 1 of 2 tuning:     formula_ridge (2.4s)
i 2 of 2 tuning:     formula_lasso
✔ 2 of 2 tuning:     formula_lasso (1.8s)

# Rank dos melhores modelos 
modelos_rank <- tunagem %>% workflowsets::rank_results() %>% print()

# A tibble: 100 × 9
   wflow_id      .config    .metric  mean std_err     n preprocessor model  rank
   <chr>         <chr>      <chr>   <dbl>   <dbl> <int> <chr>        <chr> <int>
 1 formula_lasso Preproces… rmse    0.507 0.00564    10 formula      line…     1
 2 formula_lasso Preproces… rmse    0.507 0.00564    10 formula      line…     2
 3 formula_lasso Preproces… rmse    0.507 0.00564    10 formula      line…     3
 4 formula_lasso Preproces… rmse    0.507 0.00564    10 formula      line…     4
 5 formula_lasso Preproces… rmse    0.507 0.00564    10 formula      line…     5
 6 formula_lasso Preproces… rmse    0.507 0.00564    10 formula      line…     6
 7 formula_lasso Preproces… rmse    0.507 0.00564    10 formula      line…     7
 8 formula_lasso Preproces… rmse    0.507 0.00564    10 formula      line…     8
 9 formula_lasso Preproces… rmse    0.507 0.00564    10 formula      line…     9
10 formula_lasso Preproces… rmse    0.507 0.00564    10 formula      line…    10
# ℹ 90 more rows

# Selecionando os melhores modelos 
melhor_ridge <- 
  tunagem %>% 
  workflowsets::extract_workflow_set_result("formula_ridge") %>% 
  tune::select_best(metric = "rmse") 

melhor_lasso <- 
  tunagem %>% 
  workflowsets::extract_workflow_set_result("formula_lasso") %>% 
  tune::select_best(metric ="rmse")

# Finalizando os modelos 
finalizando_ridge <- 
  tunagem %>% 
  workflowsets::extract_workflow("formula_ridge") %>% 
  tune::finalize_workflow(melhor_ridge) %>% 
  tune::last_fit(split = dados_split)

finalizando_lasso <- 
  tunagem %>% 
  workflowsets::extract_workflow("formula_lasso") %>% 
  tune::finalize_workflow(melhor_lasso) %>% 
  tune::last_fit(split = dados_split)

# Visualizando as métricas do modelo Ridge
finalizando_ridge %>% workflowsets::collect_metrics()

# A tibble: 2 × 4
  .metric .estimator .estimate .config             
  <chr>   <chr>          <dbl> <chr>               
1 rmse    standard       0.965 Preprocessor1_Model1
2 rsq     standard       0.999 Preprocessor1_Model1

# Visualizando as métricas do modelo Lasso
finalizando_lasso %>% workflowsets::collect_metrics()

# A tibble: 2 × 4
  .metric .estimator .estimate .config             
  <chr>   <chr>          <dbl> <chr>               
1 rmse    standard       0.503 Preprocessor1_Model1
2 rsq     standard       0.999 Preprocessor1_Model1

Avaliando o risco preditivo dos modelos, nota-se que o modelo Lasso apresentou um Erro Quadrático Médio (EQM) de \(0.503\), enquanto o modelo Ridge apresentou um EQM de \(0.965\). Além disso, observa-se que ambos os modelos apresentaram um \(R^{2}\) de \(0.999\). Como o risco preditivo do modelo Lasso foi menor que o do modelo Ridge, então eu escolheria o modelo Lasso para fazer as previsões.

# Visualizando predições do modelo Ridge
finalizando_ridge %>% workflowsets::collect_predictions()

# A tibble: 1,000 × 5
     .pred id                .row       y .config             
     <dbl> <chr>            <int>   <dbl> <chr>               
 1  15.3   train/test split    14  16.4   Preprocessor1_Model1
 2  12.1   train/test split    15  12.7   Preprocessor1_Model1
 3   0.246 train/test split    20   0.182 Preprocessor1_Model1
 4 -16.4   train/test split    22 -17.9   Preprocessor1_Model1
 5   9.21  train/test split    23  10.4   Preprocessor1_Model1
 6   9.96  train/test split    29  10.2   Preprocessor1_Model1
 7  11.2   train/test split    33  11.3   Preprocessor1_Model1
 8   4.25  train/test split    36   4.71  Preprocessor1_Model1
 9  -1.89  train/test split    38  -2.08  Preprocessor1_Model1
10   5.75  train/test split    44   5.25  Preprocessor1_Model1
# ℹ 990 more rows

# Visualizando predições do modelo Lasso
finalizando_lasso %>% workflowsets::collect_predictions()

# A tibble: 1,000 × 5
     .pred id                .row       y .config             
     <dbl> <chr>            <int>   <dbl> <chr>               
 1  16.3   train/test split    14  16.4   Preprocessor1_Model1
 2  12.8   train/test split    15  12.7   Preprocessor1_Model1
 3   0.256 train/test split    20   0.182 Preprocessor1_Model1
 4 -17.4   train/test split    22 -17.9   Preprocessor1_Model1
 5   9.76  train/test split    23  10.4   Preprocessor1_Model1
 6  10.6   train/test split    29  10.2   Preprocessor1_Model1
 7  11.9   train/test split    33  11.3   Preprocessor1_Model1
 8   4.52  train/test split    36   4.71  Preprocessor1_Model1
 9  -1.99  train/test split    38  -2.08  Preprocessor1_Model1
10   6.15  train/test split    44   5.25  Preprocessor1_Model1
# ℹ 990 more rows

# Extraindo o modelo Ridge
modelo_final_ridge <- 
  finalizando_ridge %>% 
  extract_fit_parsnip() 

# Extraindo o modelo Lasso
modelo_final_lasso <- 
  finalizando_lasso %>% 
  extract_fit_parsnip()

# Visualizando os coeficientes estimados do modelo Ridge
coeficientes_ridge <- modelo_final_ridge %>% 
  tidy() %>% 
  filter(term != "(Intercept)") %>% print()

# A tibble: 20 × 3
   term  estimate  penalty
   <chr>    <dbl>    <dbl>
 1 x1        6.55 1.35e-10
 2 x2       -4.70 1.35e-10
 3 x3        1.87 1.35e-10
 4 x4        3.77 1.35e-10
 5 x5        8.43 1.35e-10
 6 x6        0    1.35e-10
 7 x7        0    1.35e-10
 8 x8        0    1.35e-10
 9 x9        0    1.35e-10
10 x10       0    1.35e-10
11 x11       0    1.35e-10
12 x12       0    1.35e-10
13 x13       0    1.35e-10
14 x14       0    1.35e-10
15 x15       0    1.35e-10
16 x16       0    1.35e-10
17 x17       0    1.35e-10
18 x18       0    1.35e-10
19 x19       0    1.35e-10
20 x20       0    1.35e-10

# Visualizando os coeficientes estimados do modelo Lasso
coeficientes_lasso <- modelo_final_lasso %>% 
  tidy() %>% 
  filter(term != "(Intercept)") %>% print()

# A tibble: 20 × 3
   term  estimate  penalty
   <chr>    <dbl>    <dbl>
 1 x1        6.95 1.35e-10
 2 x2       -4.96 1.35e-10
 3 x3        1.97 1.35e-10
 4 x4        3.97 1.35e-10
 5 x5        8.96 1.35e-10
 6 x6        0    1.35e-10
 7 x7        0    1.35e-10
 8 x8        0    1.35e-10
 9 x9        0    1.35e-10
10 x10       0    1.35e-10
11 x11       0    1.35e-10
12 x12       0    1.35e-10
13 x13       0    1.35e-10
14 x14       0    1.35e-10
15 x15       0    1.35e-10
16 x16       0    1.35e-10
17 x17       0    1.35e-10
18 x18       0    1.35e-10
19 x19       0    1.35e-10
20 x20       0    1.35e-10

O modelo Lasso gerou um vetor esparso de coeficientes estimados, pois assim como na penalização AIC é realizada a seleção de variáveis, consequentemente, alguns coeficientes são zerados, o mesmo não acontece com o modelo Ridge.

# Fazendo previsões 
dados_novos <- dados[sample(1:nrow(dados), 10), -1]

# Fazendo previsões com o modelo Ridge
predict(finalizando_ridge$.workflow[[1]], 
                           new_data = dados_novos)

# A tibble: 10 × 1
    .pred
    <dbl>
 1 -20.3 
 2   5.21
 3  15.4 
 4   1.21
 5 -17.6 
 6 -29.0 
 7   3.03
 8  16.9 
 9   8.68
10  16.4 

# Fazendo previsões com o modelo Lasso
predict(finalizando_lasso$.workflow[[1]], 
                           new_data = dados_novos)

# A tibble: 10 × 1
    .pred
    <dbl>
 1 -21.5 
 2   5.58
 3  16.2 
 4   1.33
 5 -18.6 
 6 -30.6 
 7   3.25
 8  17.9 
 9   9.27
10  17.4 

# Adicionando as previsões com o modelo Ridge ao conjunto de dados original
augment(finalizando_ridge$.workflow[[1]], 
                         new_data = dados_novos)

# A tibble: 10 × 21
    .pred     x1     x2     x3     x4     x5    x6    x7    x8    x9   x10   x11
    <dbl>  <dbl>  <dbl>  <dbl>  <dbl>  <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
 1 -20.3  -1.25   0.763 -0.719 -1.25  -0.292     0     0     0     0     0     0
 2   5.21  1.95   1.29  -1.12   0.403 -0.110     0     0     0     0     0     0
 3  15.4   1.08  -1.06   0.714  1.70  -0.532     0     0     0     0     0     0
 4   1.21 -1.02  -1.48  -0.677 -1.24   0.815     0     0     0     0     0     0
 5 -17.6  -2.03   1.49  -1.40   0.406  0.458     0     0     0     0     0     0
 6 -29.0  -1.75   1.53  -1.88  -0.506 -0.576     0     0     0     0     0     0
 7   3.03 -0.988 -0.563 -0.308 -0.195  0.970     0     0     0     0     0     0
 8  16.9   0.808  0.185  1.36   0.118  1.12      0     0     0     0     0     0
 9   8.68 -0.148 -0.258  0.806 -1.27   1.39      0     0     0     0     0     0
10  16.4   0.774  0.509  0.424  0.473  1.32      0     0     0     0     0     0
# ℹ 9 more variables: x12 <dbl>, x13 <dbl>, x14 <dbl>, x15 <dbl>, x16 <dbl>,
#   x17 <dbl>, x18 <dbl>, x19 <dbl>, x20 <dbl>

# Adicionando as previsões com o modelo Lasso ao conjunto de dados original
augment(finalizando_lasso$.workflow[[1]], 
                         new_data = dados_novos)

# A tibble: 10 × 21
    .pred     x1     x2     x3     x4     x5    x6    x7    x8    x9   x10   x11
    <dbl>  <dbl>  <dbl>  <dbl>  <dbl>  <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
 1 -21.5  -1.25   0.763 -0.719 -1.25  -0.292     0     0     0     0     0     0
 2   5.58  1.95   1.29  -1.12   0.403 -0.110     0     0     0     0     0     0
 3  16.2   1.08  -1.06   0.714  1.70  -0.532     0     0     0     0     0     0
 4   1.33 -1.02  -1.48  -0.677 -1.24   0.815     0     0     0     0     0     0
 5 -18.6  -2.03   1.49  -1.40   0.406  0.458     0     0     0     0     0     0
 6 -30.6  -1.75   1.53  -1.88  -0.506 -0.576     0     0     0     0     0     0
 7   3.25 -0.988 -0.563 -0.308 -0.195  0.970     0     0     0     0     0     0
 8  17.9   0.808  0.185  1.36   0.118  1.12      0     0     0     0     0     0
 9   9.27 -0.148 -0.258  0.806 -1.27   1.39      0     0     0     0     0     0
10  17.4   0.774  0.509  0.424  0.473  1.32      0     0     0     0     0     0
# ℹ 9 more variables: x12 <dbl>, x13 <dbl>, x14 <dbl>, x15 <dbl>, x16 <dbl>,
#   x17 <dbl>, x18 <dbl>, x19 <dbl>, x20 <dbl>

Questão 2:

Considere o melhor modelo da questão anterior, e compare-o com a regressão Elastic Net. Faça uma comparação justa dos modelos, utilizando workflow_set e workflow_map. Avalie o risco preditivo dos modelos e compare os coeficientes estimados. Qual dos modelos você escolheria para fazer previsões? Explique!

Resposta:

Como o melhor modelo na questão anterior foi o modelo Lasso, então irei compará-lo com o modelo Elastic Net.

rm(list = ls())

# Carregando pacotes 
library(tidyverse)
library(tidymodels)
library(tibble)
library(purrr)
library(ggplot2)
library(patchwork)
library(workflowsets)
library(yardstick)
library(glmnet)

# Dando preferencias as funcoes do tidymodels 
tidymodels::tidymodels_prefer()

# Setando a semente 
set.seed(0)

# Função para gerar os dados 
gerando_dados <- function(n = 5000L){
  regressao <- function(i){
    x <- rnorm(n = 5000L, 0, 1)
    target <- 7*x[1L] - 5*x[2L] + 2*x[3L] + 4*x[4L] + 9*x[5L] + rnorm(1L, 0, 0.5)
    tibble(
      y = target,
      x1 = x[1L],
      x2 = x[2L],
      x3 = x[3L],
      x4 = x[4L],
      x5 = x[5L]
    )
  }
  dados <- purrr::map(.x = 1L:n, .f = regressao) %>% 
    purrr::list_rbind()
  
  parte_esparsa <- matrix(0, n, 15)
  
  dados <- cbind(dados, parte_esparsa)
  colnames(dados) <- c("y", paste0("x", 1L:20L))
  tibble::as_tibble(dados)
}

dados <- gerando_dados()

# Realizando o hold-out 
dados_split <- rsample::initial_split(dados, prop = 0.8, strata = "y")
treino <- rsample::training(dados_split)
teste <- rsample::testing(dados_split)

# Setando o modelo (set engine) 
modelo_lasso <- 
  parsnip::linear_reg(penalty = tune::tune(), mixture = 1) %>% 
  parsnip::set_mode("regression") %>% 
  parsnip::set_engine("glmnet")

modelo_elastic <- 
  parsnip::linear_reg(penalty = tune::tune(), mixture = tune::tune()) %>% 
  parsnip::set_mode("regression") %>% 
  parsnip::set_engine("glmnet")

# Criando workflows 
all_wf <- 
  workflowsets::workflow_set(
    preproc = list(y ~ .),
    models = list(lasso = modelo_lasso, elastic = modelo_elastic), 
    cross = TRUE
  )

# Validação cruzada 
set.seed(0)
cv <- rsample::vfold_cv(treino, v = 10L)

# Setando a métrica 
metrica <- yardstick::metric_set(rmse)

# Tunagem dos hiperparâmetros 
tunagem <- 
  all_wf %>% 
  workflowsets::workflow_map(
    seed = 0, 
    verbose = TRUE,
    resamples = cv,
    grid = 50,
    metrics = metrica
  )

i 1 of 2 tuning:     formula_lasso

✔ 1 of 2 tuning:     formula_lasso (1.7s)

i 2 of 2 tuning:     formula_elastic

✔ 2 of 2 tuning:     formula_elastic (39.9s)

# Rank dos melhores modelos 
modelos_rank <- tunagem %>% workflowsets::rank_results() %>% print()

# A tibble: 100 × 9
   wflow_id        .config  .metric  mean std_err     n preprocessor model  rank
   <chr>           <chr>    <chr>   <dbl>   <dbl> <int> <chr>        <chr> <int>
 1 formula_elastic Preproc… rmse    0.506 0.00572    10 formula      line…     1
 2 formula_elastic Preproc… rmse    0.506 0.00570    10 formula      line…     2
 3 formula_elastic Preproc… rmse    0.506 0.00566    10 formula      line…     3
 4 formula_elastic Preproc… rmse    0.506 0.00570    10 formula      line…     4
 5 formula_elastic Preproc… rmse    0.506 0.00568    10 formula      line…     5
 6 formula_elastic Preproc… rmse    0.506 0.00576    10 formula      line…     6
 7 formula_elastic Preproc… rmse    0.506 0.00565    10 formula      line…     7
 8 formula_elastic Preproc… rmse    0.506 0.00580    10 formula      line…     8
 9 formula_elastic Preproc… rmse    0.506 0.00574    10 formula      line…     9
10 formula_elastic Preproc… rmse    0.507 0.00566    10 formula      line…    10
# ℹ 90 more rows

# Selecionando os melhores modelos 
melhor_lasso <- 
  tunagem %>% 
  workflowsets::extract_workflow_set_result("formula_lasso") %>% 
  tune::select_best(metric ="rmse")

melhor_elastic <- 
  tunagem %>% 
  workflowsets::extract_workflow_set_result("formula_elastic") %>% 
  tune::select_best(metric = "rmse")

# Finalizando os modelos 
finalizando_lasso <- 
  tunagem %>% 
  workflowsets::extract_workflow("formula_lasso") %>% 
  tune::finalize_workflow(melhor_lasso) %>% 
  tune::last_fit(split = dados_split)

finalizando_elastic <- 
  tunagem %>% 
  workflowsets::extract_workflow("formula_elastic") %>% 
  tune::finalize_workflow(melhor_elastic) %>% 
  tune::last_fit(split = dados_split)

## Visualizando as métricas do modelo Lasso
finalizando_lasso %>% workflowsets::collect_metrics()

# A tibble: 2 × 4
  .metric .estimator .estimate .config             
  <chr>   <chr>          <dbl> <chr>               
1 rmse    standard       0.503 Preprocessor1_Model1
2 rsq     standard       0.999 Preprocessor1_Model1

# Visualizando as métricas do modelo Elastic Net
finalizando_elastic %>% workflowsets::collect_metrics()

# A tibble: 2 × 4
  .metric .estimator .estimate .config             
  <chr>   <chr>          <dbl> <chr>               
1 rmse    standard       0.502 Preprocessor1_Model1
2 rsq     standard       0.999 Preprocessor1_Model1

Avaliando o risco preditivo dos modelos, nota-se que o modelo Lasso apresentou um Erro Quadrático Médio (EQM) de \(0.503\), enquanto o modelo Elastic Net apresentou um EQM de \(0.502\). Além disso, observa-se que ambos os modelos apresentaram um \(R^{2}\) de \(0.999\). Como o risco preditivo do modelo Elastic Net foi um pouco menor que o do modelo Lasso, então eu escolheria o modelo Elastic Net para fazer as previsões.

# Visualizando predições do modelo Lasso
finalizando_lasso %>% workflowsets::collect_predictions()

# A tibble: 1,000 × 5
     .pred id                .row       y .config             
     <dbl> <chr>            <int>   <dbl> <chr>               
 1  16.3   train/test split    14  16.4   Preprocessor1_Model1
 2  12.8   train/test split    15  12.7   Preprocessor1_Model1
 3   0.256 train/test split    20   0.182 Preprocessor1_Model1
 4 -17.4   train/test split    22 -17.9   Preprocessor1_Model1
 5   9.76  train/test split    23  10.4   Preprocessor1_Model1
 6  10.6   train/test split    29  10.2   Preprocessor1_Model1
 7  11.9   train/test split    33  11.3   Preprocessor1_Model1
 8   4.52  train/test split    36   4.71  Preprocessor1_Model1
 9  -1.99  train/test split    38  -2.08  Preprocessor1_Model1
10   6.15  train/test split    44   5.25  Preprocessor1_Model1
# ℹ 990 more rows

# Visualizando predições do modelo Elastic Net
finalizando_elastic %>% workflowsets::collect_predictions()

# A tibble: 1,000 × 5
     .pred id                .row       y .config             
     <dbl> <chr>            <int>   <dbl> <chr>               
 1  16.3   train/test split    14  16.4   Preprocessor1_Model1
 2  12.8   train/test split    15  12.7   Preprocessor1_Model1
 3   0.261 train/test split    20   0.182 Preprocessor1_Model1
 4 -17.4   train/test split    22 -17.9   Preprocessor1_Model1
 5   9.76  train/test split    23  10.4   Preprocessor1_Model1
 6  10.6   train/test split    29  10.2   Preprocessor1_Model1
 7  11.9   train/test split    33  11.3   Preprocessor1_Model1
 8   4.52  train/test split    36   4.71  Preprocessor1_Model1
 9  -1.99  train/test split    38  -2.08  Preprocessor1_Model1
10   6.14  train/test split    44   5.25  Preprocessor1_Model1
# ℹ 990 more rows

# Extraindo o modelo Lasso
modelo_final_lasso <- 
  finalizando_lasso %>% 
  extract_fit_parsnip() 

# Extraindo o modelo Elastic Net
modelo_final_elastic <- 
  finalizando_elastic %>% 
  extract_fit_parsnip()

# Visualizando os coeficientes estimados do modelo Lasso
coeficientes_lasso <- modelo_final_lasso %>% 
  tidy() %>% 
  filter(term != "(Intercept)") %>% print()

# A tibble: 20 × 3
   term  estimate  penalty
   <chr>    <dbl>    <dbl>
 1 x1        6.95 1.35e-10
 2 x2       -4.96 1.35e-10
 3 x3        1.97 1.35e-10
 4 x4        3.97 1.35e-10
 5 x5        8.96 1.35e-10
 6 x6        0    1.35e-10
 7 x7        0    1.35e-10
 8 x8        0    1.35e-10
 9 x9        0    1.35e-10
10 x10       0    1.35e-10
11 x11       0    1.35e-10
12 x12       0    1.35e-10
13 x13       0    1.35e-10
14 x14       0    1.35e-10
15 x15       0    1.35e-10
16 x16       0    1.35e-10
17 x17       0    1.35e-10
18 x18       0    1.35e-10
19 x19       0    1.35e-10
20 x20       0    1.35e-10

# Visualizando os coeficientes estimados do modelo Elastic Net
coeficientes_elastic <- modelo_final_elastic %>% 
  tidy() %>% 
  filter(term != "(Intercept)") %>% print()

# A tibble: 20 × 3
   term  estimate       penalty
   <chr>    <dbl>         <dbl>
 1 x1        6.95 0.00000000236
 2 x2       -4.97 0.00000000236
 3 x3        1.97 0.00000000236
 4 x4        3.97 0.00000000236
 5 x5        8.96 0.00000000236
 6 x6        0    0.00000000236
 7 x7        0    0.00000000236
 8 x8        0    0.00000000236
 9 x9        0    0.00000000236
10 x10       0    0.00000000236
11 x11       0    0.00000000236
12 x12       0    0.00000000236
13 x13       0    0.00000000236
14 x14       0    0.00000000236
15 x15       0    0.00000000236
16 x16       0    0.00000000236
17 x17       0    0.00000000236
18 x18       0    0.00000000236
19 x19       0    0.00000000236
20 x20       0    0.00000000236

# Fazendo previsões 
dados_novos <- dados[sample(1:nrow(dados), 10), -1]

# Fazendo previsões com o modelo Lasso
predict(finalizando_lasso$.workflow[[1]], 
                           new_data = dados_novos)

# A tibble: 10 × 1
    .pred
    <dbl>
 1 -21.5 
 2   5.58
 3  16.2 
 4   1.33
 5 -18.6 
 6 -30.6 
 7   3.25
 8  17.9 
 9   9.27
10  17.4 

# Fazendo previsões com o modelo Elastic Net
predict(finalizando_elastic$.workflow[[1]], 
                           new_data = dados_novos)

# A tibble: 10 × 1
    .pred
    <dbl>
 1 -21.5 
 2   5.57
 3  16.2 
 4   1.32
 5 -18.6 
 6 -30.7 
 7   3.24
 8  17.9 
 9   9.26
10  17.4 

# Adicionando as previsões com o modelo Lasso ao conjunto de dados original
augment(finalizando_lasso$.workflow[[1]], 
                         new_data = dados_novos)

# A tibble: 10 × 21
    .pred     x1     x2     x3     x4     x5    x6    x7    x8    x9   x10   x11
    <dbl>  <dbl>  <dbl>  <dbl>  <dbl>  <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
 1 -21.5  -1.25   0.763 -0.719 -1.25  -0.292     0     0     0     0     0     0
 2   5.58  1.95   1.29  -1.12   0.403 -0.110     0     0     0     0     0     0
 3  16.2   1.08  -1.06   0.714  1.70  -0.532     0     0     0     0     0     0
 4   1.33 -1.02  -1.48  -0.677 -1.24   0.815     0     0     0     0     0     0
 5 -18.6  -2.03   1.49  -1.40   0.406  0.458     0     0     0     0     0     0
 6 -30.6  -1.75   1.53  -1.88  -0.506 -0.576     0     0     0     0     0     0
 7   3.25 -0.988 -0.563 -0.308 -0.195  0.970     0     0     0     0     0     0
 8  17.9   0.808  0.185  1.36   0.118  1.12      0     0     0     0     0     0
 9   9.27 -0.148 -0.258  0.806 -1.27   1.39      0     0     0     0     0     0
10  17.4   0.774  0.509  0.424  0.473  1.32      0     0     0     0     0     0
# ℹ 9 more variables: x12 <dbl>, x13 <dbl>, x14 <dbl>, x15 <dbl>, x16 <dbl>,
#   x17 <dbl>, x18 <dbl>, x19 <dbl>, x20 <dbl>

# Adicionando as previsões com o modelo Elastic Net ao conjunto de dados original
augment(finalizando_elastic$.workflow[[1]], 
                         new_data = dados_novos)

# A tibble: 10 × 21
    .pred     x1     x2     x3     x4     x5    x6    x7    x8    x9   x10   x11
    <dbl>  <dbl>  <dbl>  <dbl>  <dbl>  <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
 1 -21.5  -1.25   0.763 -0.719 -1.25  -0.292     0     0     0     0     0     0
 2   5.57  1.95   1.29  -1.12   0.403 -0.110     0     0     0     0     0     0
 3  16.2   1.08  -1.06   0.714  1.70  -0.532     0     0     0     0     0     0
 4   1.32 -1.02  -1.48  -0.677 -1.24   0.815     0     0     0     0     0     0
 5 -18.6  -2.03   1.49  -1.40   0.406  0.458     0     0     0     0     0     0
 6 -30.7  -1.75   1.53  -1.88  -0.506 -0.576     0     0     0     0     0     0
 7   3.24 -0.988 -0.563 -0.308 -0.195  0.970     0     0     0     0     0     0
 8  17.9   0.808  0.185  1.36   0.118  1.12      0     0     0     0     0     0
 9   9.26 -0.148 -0.258  0.806 -1.27   1.39      0     0     0     0     0     0
10  17.4   0.774  0.509  0.424  0.473  1.32      0     0     0     0     0     0
# ℹ 9 more variables: x12 <dbl>, x13 <dbl>, x14 <dbl>, x15 <dbl>, x16 <dbl>,
#   x17 <dbl>, x18 <dbl>, x19 <dbl>, x20 <dbl>

Questão 3:

Utilize o método K - Nearest Neighbors para prever o preço médio ( variável MEDV) de uma casa em diferentes áreas da cidade de Boston com base em várias características socioeconômicas e geográficas. Faça uma descritiva dos dados e realize a fase de preprocessamento dos dados.

Você deverá:

1. Explorar as variáveis, identificando as variáveis que possuem um comportamento assimétrico;
   
2. Pré-processar os dados e incluir o preprocessamento no pipeline. No preprocessamento, você deverá:
   

• Realizar a transformação de Yeo-Johnson nas variáveis que possuem um comportamento assimétrico. No pacote recipes, utilize step_YeoJohnson;
• Incluir no preprocessamento a eliminação de variáveis altamente correlacionadas;
  
• Incluir no preprocessamento a eliminação de covariáveis com zero variância.
  

3. Estimar o risco preditivo do modelo. Houve boas previsões? Explique!
   
4. Você deverá estratificar os dados em \(80 \%\) para treino e \(20 \%\) para teste, com base na variável target.
   
5. Utilize na validação cruzada 10-fold cross-validation.
   

Acesse o link para baixar os dados.

Resposta:

rm(list = ls())

# Carregando pacotes 
library(tidyverse)
library(tidymodels)
library(tibble)
library(purrr)
library(ggplot2)
library(patchwork)
library(workflowsets)
library(yardstick)
library(glmnet)
library(kknn)
library(visdat)
library(janitor)
library(parsnip)
library(skimr)

# Dando preferencias as funcoes do tidymodels 
tidymodels::tidymodels_prefer()

# Setando a semente 
set.seed(0)

# Carregando os dados 
dados <- read.csv("~/JOANA/ESTATÍSTICA/2024.1/Aprendizagem de Máquina/AM/Prova2/dados/boston.csv")

# Limpando os nomes das variáveis 
dados <-
  dados %>% 
  janitor::clean_names()


# Visualizando as primeiras observações dos dados
head(dados)

     crim zn indus chas   nox    rm  age    dis rad tax ptratio      b lstat
1 0.00632 18  2.31    0 0.538 6.575 65.2 4.0900   1 296    15.3 396.90  4.98
2 0.02731  0  7.07    0 0.469 6.421 78.9 4.9671   2 242    17.8 396.90  9.14
3 0.02729  0  7.07    0 0.469 7.185 61.1 4.9671   2 242    17.8 392.83  4.03
4 0.03237  0  2.18    0 0.458 6.998 45.8 6.0622   3 222    18.7 394.63  2.94
5 0.06905  0  2.18    0 0.458 7.147 54.2 6.0622   3 222    18.7 396.90  5.33
6 0.02985  0  2.18    0 0.458 6.430 58.7 6.0622   3 222    18.7 394.12  5.21
  medv
1 24.0
2 21.6
3 34.7
4 33.4
5 36.2
6 28.7

# Visualizando a estrutura dos dados
glimpse(dados)

Rows: 506
Columns: 14
$ crim    <dbl> 0.00632, 0.02731, 0.02729, 0.03237, 0.06905, 0.02985, 0.08829,…
$ zn      <dbl> 18.0, 0.0, 0.0, 0.0, 0.0, 0.0, 12.5, 12.5, 12.5, 12.5, 12.5, 1…
$ indus   <dbl> 2.31, 7.07, 7.07, 2.18, 2.18, 2.18, 7.87, 7.87, 7.87, 7.87, 7.…
$ chas    <int> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,…
$ nox     <dbl> 0.538, 0.469, 0.469, 0.458, 0.458, 0.458, 0.524, 0.524, 0.524,…
$ rm      <dbl> 6.575, 6.421, 7.185, 6.998, 7.147, 6.430, 6.012, 6.172, 5.631,…
$ age     <dbl> 65.2, 78.9, 61.1, 45.8, 54.2, 58.7, 66.6, 96.1, 100.0, 85.9, 9…
$ dis     <dbl> 4.0900, 4.9671, 4.9671, 6.0622, 6.0622, 6.0622, 5.5605, 5.9505…
$ rad     <int> 1, 2, 2, 3, 3, 3, 5, 5, 5, 5, 5, 5, 5, 4, 4, 4, 4, 4, 4, 4, 4,…
$ tax     <dbl> 296, 242, 242, 222, 222, 222, 311, 311, 311, 311, 311, 311, 31…
$ ptratio <dbl> 15.3, 17.8, 17.8, 18.7, 18.7, 18.7, 15.2, 15.2, 15.2, 15.2, 15…
$ b       <dbl> 396.90, 396.90, 392.83, 394.63, 396.90, 394.12, 395.60, 396.90…
$ lstat   <dbl> 4.98, 9.14, 4.03, 2.94, 5.33, 5.21, 12.43, 19.15, 29.93, 17.10…
$ medv    <dbl> 24.0, 21.6, 34.7, 33.4, 36.2, 28.7, 22.9, 27.1, 16.5, 18.9, 15…

# Estatística descritiva dos dados
skimr::skim(dados)

Data summary

Name	dados
Number of rows	506
Number of columns	14
_______________________
Column type frequency:
numeric	14
________________________
Group variables	None

Variable type: numeric

skim_variable	n_missing	complete_rate	mean	sd	p0	p25	p50	p75	p100	hist
crim	0	1	3.61	8.60	0.01	0.08	0.26	3.68	88.98	▇▁▁▁▁
zn	0	1	11.36	23.32	0.00	0.00	0.00	12.50	100.00	▇▁▁▁▁
indus	0	1	11.14	6.86	0.46	5.19	9.69	18.10	27.74	▇▆▁▇▁
chas	0	1	0.07	0.25	0.00	0.00	0.00	0.00	1.00	▇▁▁▁▁
nox	0	1	0.55	0.12	0.38	0.45	0.54	0.62	0.87	▇▇▆▅▁
rm	0	1	6.28	0.70	3.56	5.89	6.21	6.62	8.78	▁▂▇▂▁
age	0	1	68.57	28.15	2.90	45.02	77.50	94.07	100.00	▂▂▂▃▇
dis	0	1	3.80	2.11	1.13	2.10	3.21	5.19	12.13	▇▅▂▁▁
rad	0	1	9.55	8.71	1.00	4.00	5.00	24.00	24.00	▇▂▁▁▃
tax	0	1	408.24	168.54	187.00	279.00	330.00	666.00	711.00	▇▇▃▁▇
ptratio	0	1	18.46	2.16	12.60	17.40	19.05	20.20	22.00	▁▃▅▅▇
b	0	1	356.67	91.29	0.32	375.38	391.44	396.22	396.90	▁▁▁▁▇
lstat	0	1	12.65	7.14	1.73	6.95	11.36	16.96	37.97	▇▇▅▂▁
medv	0	1	22.53	9.20	5.00	17.02	21.20	25.00	50.00	▂▇▅▁▁

Observa-se que o conjunto de dados contém 506 observações e 14 variáveis. Além disso, observa-se que as variáveis crim, zn, indus, nox, rm, age, dis, tax, ptratio, b, lstat e medv são do tipo numérico, enquanto as variáveis chas e rad são do tipo inteiro categóricas.

# Visualizando as variáveis que possuem um comportamento assimétrico
DescTools::Desc(dados)

────────────────────────────────────────────────────────────────────────────── 
Describe dados (data.frame):

data frame: 506 obs. of  14 variables
        506 complete cases (100.0%)

  Nr  Class  ColName  NAs  Levels
  1   num    crim     .          
  2   num    zn       .          
  3   num    indus    .          
  4   int    chas     .          
  5   num    nox      .          
  6   num    rm       .          
  7   num    age      .          
  8   num    dis      .          
  9   int    rad      .          
  10  num    tax      .          
  11  num    ptratio  .          
  12  num    b        .          
  13  num    lstat    .          
  14  num    medv     .          


────────────────────────────────────────────────────────────────────────────── 
1 - crim (numeric)

     length         n       NAs    unique        0s       mean     meanCI'
        506       506         0       504         0   3.613524   2.862262
               100.0%      0.0%                0.0%              4.364786
                                                                         
        .05       .10       .25    median       .75        .90        .95
   0.027910  0.038195  0.082045  0.256510  3.677083  10.753000  15.789150
                                                                         
      range        sd     vcoef       mad       IQR       skew       kurt
  88.969880  8.601545  2.380376  0.328322  3.595038   5.192222  36.595816
                                                                         
lowest : 0.00632, 0.00906, 0.01096, 0.01301, 0.01311
highest: 45.7461, 51.1358, 67.9208, 73.5341, 88.9762

' 95%-CI (classic)

────────────────────────────────────────────────────────────────────────────── 
2 - zn (numeric)

  length       n    NAs  unique     0s   mean  meanCI'
     506     506      0      26    372  11.36    9.33
          100.0%   0.0%          73.5%          13.40
                                                     
     .05     .10    .25  median    .75    .90     .95
    0.00    0.00   0.00    0.00  12.50  42.50   80.00
                                                     
   range      sd  vcoef     mad    IQR   skew    kurt
  100.00   23.32   2.05    0.00  12.50   2.21    3.95
                                                     
lowest : 0.0 (372), 12.5 (10), 17.5, 18.0, 20.0 (21)
highest: 82.5 (2), 85.0 (2), 90.0 (5), 95.0 (4), 100.0

heap(?): remarkable frequency (73.5%) for the mode(s) (= 0)

' 95%-CI (classic)

────────────────────────────────────────────────────────────────────────────── 
3 - indus (numeric)

  length       n    NAs  unique     0s   mean  meanCI'
     506     506      0      76      0  11.14   10.54
          100.0%   0.0%           0.0%          11.74
                                                     
     .05     .10    .25  median    .75    .90     .95
    2.18    2.91   5.19    9.69  18.10  19.58   21.89
                                                     
   range      sd  vcoef     mad    IQR   skew    kurt
   27.28    6.86   0.62    9.37  12.91   0.29   -1.24
                                                     
lowest : 0.46, 0.74, 1.21, 1.22, 1.25 (2)
highest: 18.1 (132), 19.58 (30), 21.89 (15), 25.65 (7), 27.74 (5)

heap(?): remarkable frequency (26.1%) for the mode(s) (= 18.1)

' 95%-CI (classic)

────────────────────────────────────────────────────────────────────────────── 
4 - chas (integer - dichotomous)

  length      n    NAs unique
     506    506      0      2
         100.0%   0.0%       

   freq   perc  lci.95  uci.95'
0   471  93.1%   90.5%   95.0%
1    35   6.9%    5.0%    9.5%

' 95%-CI (Wilson)

────────────────────────────────────────────────────────────────────────────── 
5 - nox (numeric)

   length        n      NAs   unique       0s     mean    meanCI'
      506      506        0       81        0  0.55470   0.54457
            100.0%     0.0%              0.0%            0.56482
                                                                
      .05      .10      .25   median      .75      .90       .95
  0.40925  0.42700  0.44900  0.53800  0.62400  0.71300   0.74000
                                                                
    range       sd    vcoef      mad      IQR     skew      kurt
  0.48600  0.11588  0.20890  0.12973  0.17500  0.72499  -0.08741
                                                                
lowest : 0.385, 0.389, 0.392 (2), 0.394, 0.398 (2)
highest: 0.713 (18), 0.718 (6), 0.74 (13), 0.77 (8), 0.871 (16)

' 95%-CI (classic)

────────────────────────────────────────────────────────────────────────────── 
6 - rm (numeric)

  length       n     NAs  unique      0s    mean  meanCI'
     506     506       0     446       0  6.2846  6.2233
          100.0%    0.0%            0.0%          6.3460
                                                        
     .05     .10     .25  median     .75     .90     .95
  5.3140  5.5935  5.8855  6.2085  6.6235  7.1515  7.5875
                                                        
   range      sd   vcoef     mad     IQR    skew    kurt
  5.2190  0.7026  0.1118  0.5122  0.7380  0.4012  1.8418
                                                        
lowest : 3.561, 3.863, 4.138 (2), 4.368, 4.519
highest: 8.375, 8.398, 8.704, 8.725, 8.78

' 95%-CI (classic)

────────────────────────────────────────────────────────────────────────────── 
7 - age (numeric)

  length       n     NAs  unique      0s    mean   meanCI'
     506     506       0     356       0  68.575   66.116
          100.0%    0.0%            0.0%           71.033
                                                         
     .05     .10     .25  median     .75     .90      .95
  17.725  26.950  45.025  77.500  94.075  98.800  100.000
                                                         
   range      sd   vcoef     mad     IQR    skew     kurt
  97.100  28.149   0.410  28.985  49.050  -0.595   -0.978
                                                         
lowest : 2.9, 6.0, 6.2, 6.5, 6.6 (2)
highest: 98.8 (4), 98.9 (3), 99.1, 99.3, 100.0 (43)

heap(?): remarkable frequency (8.5%) for the mode(s) (= 100)

' 95%-CI (classic)

────────────────────────────────────────────────────────────────────────────── 
8 - dis (numeric)

     length         n       NAs    unique        0s      mean    meanCI'
        506       506         0       412         0  3.795043  3.611129
               100.0%      0.0%                0.0%            3.978956
                                                                       
        .05       .10       .25    median       .75       .90       .95
   1.461975  1.628300  2.100175  3.207450  5.188425  6.816600  7.827800
                                                                       
      range        sd     vcoef       mad       IQR      skew      kurt
  10.996900  2.105710  0.554858  1.914259  3.088250  1.005790  0.457592
                                                                       
lowest : 1.1296, 1.137, 1.1691, 1.1742, 1.1781
highest: 9.2203 (2), 9.2229, 10.5857 (2), 10.7103 (2), 12.1265

' 95%-CI (classic)

────────────────────────────────────────────────────────────────────────────── 
9 - rad (integer)

  length       n    NAs  unique     0s   mean  meanCI'
     506     506      0       9      0   9.55    8.79
          100.0%   0.0%           0.0%          10.31
                                                     
     .05     .10    .25  median    .75    .90     .95
    2.00    3.00   4.00    5.00  24.00  24.00   24.00
                                                     
   range      sd  vcoef     mad    IQR   skew    kurt
   23.00    8.71   0.91    2.97  20.00   1.00   -0.88
                                                     

   value  freq   perc  cumfreq  cumperc
1      1    20   4.0%       20     4.0%
2      2    24   4.7%       44     8.7%
3      3    38   7.5%       82    16.2%
4      4   110  21.7%      192    37.9%
5      5   115  22.7%      307    60.7%
6      6    26   5.1%      333    65.8%
7      7    17   3.4%      350    69.2%
8      8    24   4.7%      374    73.9%
9     24   132  26.1%      506   100.0%

' 95%-CI (classic)

────────────────────────────────────────────────────────────────────────────── 
10 - tax (numeric)

  length       n     NAs  unique      0s    mean  meanCI'
     506     506       0      66       0  408.24  393.52
          100.0%    0.0%            0.0%          422.96
                                                        
     .05     .10     .25  median     .75     .90     .95
  222.00  233.00  279.00  330.00  666.00  666.00  666.00
                                                        
   range      sd   vcoef     mad     IQR    skew    kurt
  524.00  168.54    0.41  108.23  387.00    0.67   -1.15
                                                        
lowest : 187.0, 188.0 (7), 193.0 (8), 198.0, 216.0 (5)
highest: 432.0 (9), 437.0 (15), 469.0, 666.0 (132), 711.0 (5)

heap(?): remarkable frequency (26.1%) for the mode(s) (= 666)

' 95%-CI (classic)

────────────────────────────────────────────────────────────────────────────── 
11 - ptratio (numeric)

  length       n    NAs  unique     0s   mean  meanCI'
     506     506      0      46      0  18.46   18.27
          100.0%   0.0%           0.0%          18.64
                                                     
     .05     .10    .25  median    .75    .90     .95
   14.70   14.75  17.40   19.05  20.20  20.90   21.00
                                                     
   range      sd  vcoef     mad    IQR   skew    kurt
    9.40    2.16   0.12    1.70   2.80  -0.80   -0.30
                                                     
lowest : 12.6 (3), 13.0 (12), 13.6, 14.4, 14.7 (34)
highest: 20.9 (11), 21.0 (27), 21.1, 21.2 (15), 22.0 (2)

heap(?): remarkable frequency (27.7%) for the mode(s) (= 20.2)

' 95%-CI (classic)

────────────────────────────────────────────────────────────────────────────── 
12 - b (numeric)

    length         n       NAs    unique        0s      mean    meanCI'
       506       506         0       357         0  356.6740  348.7003
              100.0%      0.0%                0.0%            364.6478
                                                                      
       .05       .10       .25    median       .75       .90       .95
   84.5900  290.2700  375.3775  391.4400  396.2250  396.9000  396.9000
                                                                      
     range        sd     vcoef       mad       IQR      skew      kurt
  396.5800   91.2949    0.2560    8.0950   20.8475   -2.8733    7.1037
                                                                      
lowest : 0.32, 2.52, 2.6, 3.5, 3.65
highest: 396.28, 396.3, 396.33, 396.42, 396.9 (121)

heap(?): remarkable frequency (23.9%) for the mode(s) (= 396.9)

' 95%-CI (classic)

────────────────────────────────────────────────────────────────────────────── 
13 - lstat (numeric)

   length       n     NAs   unique       0s     mean   meanCI'
      506     506       0      455        0  12.6531  12.0294
           100.0%    0.0%              0.0%           13.2768
                                                             
      .05     .10     .25   median      .75      .90      .95
   3.7075  4.6800  6.9500  11.3600  16.9550  23.0350  26.8075
                                                             
    range      sd   vcoef      mad      IQR     skew     kurt
  36.2400  7.1411  0.5644   7.1091  10.0050   0.9011   0.4628
                                                             
lowest : 1.73, 1.92, 1.98, 2.47, 2.87
highest: 34.37, 34.41, 34.77, 36.98, 37.97

' 95%-CI (classic)

────────────────────────────────────────────────────────────────────────────── 
14 - medv (numeric)

  length       n     NAs  unique      0s    mean  meanCI'
     506     506       0     229       0  22.533  21.730
          100.0%    0.0%            0.0%          23.336
                                                        
     .05     .10     .25  median     .75     .90     .95
  10.200  12.750  17.025  21.200  25.000  34.800  43.400
                                                        
   range      sd   vcoef     mad     IQR    skew    kurt
  45.000   9.197   0.408   5.930   7.975   1.102   1.451
                                                        
lowest : 5.0 (2), 5.6, 6.3, 7.0 (2), 7.2 (3)
highest: 46.7, 48.3, 48.5, 48.8, 50.0 (16)

' 95%-CI (classic)

Utilizando a função Desc() da library DescTools para analisar visualmente as variáveis que possuem um comportamento assimétrico, e avaliando a assimetria das variáveis com base do valor do argumento skew de cada variável, nota-se que as variáveis indus e rm possuem um comportamento simétrico, pois o valor do skewdestas variáveis estão próximos de zero, enquanto as variáveis crim, zn, nox, age, dis, tax, ptratio, b, lstat e medv possuem um comportamento assimétrico.

# Olhando rapidamento os dados
visdat::vis_dat(dados)

# Visualizando a correlação entre as variáveis 
visdat::vis_cor(dados)

set.seed(0)

# Data Splitting
dados_split <- rsample::initial_split(dados, prop = 0.8, strata = "medv")
treino <- rsample::training(dados_split)
teste <- rsample::testing(dados_split)

# Criando o conjunto de validação
cv <- rsample::vfold_cv(treino, v = 10L)

# Pré-processamento dos dados 
receita <- 
  recipes::recipe(medv ~ ., data = treino) %>%
  # Eliminando as variáveis constantes (com zero variância)
  recipes::step_zv(all_predictors()) %>%
  # Transformando as variáveis assimétricas
  recipes::step_YeoJohnson(all_numeric_predictors()) %>%
  # Transformando as variáveis categóricas em dicotômicas (0 e 1) 
  recipes::step_dummy(all_nominal_predictors()) %>%
  # Eliminando as variáveis altamente correlacionadas
  recipes::step_corr(all_numeric_predictors()) 

# Ajustando o modelo KNN 
modelo_knn <- 
  parsnip::nearest_neighbor(neighbors = tune("k")) %>% 
  parsnip::set_mode("regression") %>% 
  parsnip::set_engine("kknn")

# Criando o Workflow 
wf <- 
  workflowsets::workflow_set(
    preproc = list(formula = receita),
    models = list(knn = modelo_knn), 
    cross = TRUE
  )

# Setando a métrica
metrica <- yardstick::metric_set(rmse)

# Tunagem dos hiperparâmetros
tunagem <- 
  wf %>% 
  workflowsets::workflow_map(
    seed = 0, 
    verbose = TRUE,
    resamples = cv,
    grid = 50,
    metrics = metrica
  )

i 1 of 1 tuning:     formula_knn

✔ 1 of 1 tuning:     formula_knn (5.1s)

# Selecionando o melhor modelo
melhor_knn <- 
  tunagem %>% 
  workflowsets::extract_workflow_set_result("formula_knn") %>% 
  tune::select_best(metric = "rmse")

# Finalizando o modelo
finalizando_knn <-
  tunagem %>% 
  workflowsets::extract_workflow("formula_knn") %>% 
  tune::finalize_workflow(melhor_knn) %>% 
  tune::last_fit(split = dados_split)

# Visualizando as métricas do modelo KNN
finalizando_knn %>% workflowsets::collect_metrics()

# A tibble: 2 × 4
  .metric .estimator .estimate .config             
  <chr>   <chr>          <dbl> <chr>               
1 rmse    standard       4.74  Preprocessor1_Model1
2 rsq     standard       0.730 Preprocessor1_Model1

Em relação ao risco preditivo do modelo KNN, observa-se que o Erro Quadrático Médio (EQM) foi de \(4.74\) e o \(R^{2}\) de \(0.730\), o EQM foi relativamente bom, mas como o \(R^{2}\) não é muito alto, é provável que o modelo não faça boas previsões para alguns preços médios das casas de diferentes áreas da cidade de Boston.

# Visualizando predições do modelo KNN
finalizando_knn %>% workflowsets::collect_predictions()

# A tibble: 103 × 5
   .pred id                .row  medv .config             
   <dbl> <chr>            <int> <dbl> <chr>               
 1  18.1 train/test split    18  17.5 Preprocessor1_Model1
 2  14.1 train/test split    21  13.6 Preprocessor1_Model1
 3  16.7 train/test split    23  15.2 Preprocessor1_Model1
 4  16.1 train/test split    24  14.5 Preprocessor1_Model1
 5  16.6 train/test split    27  16.6 Preprocessor1_Model1
 6  18.4 train/test split    30  21   Preprocessor1_Model1
 7  18.1 train/test split    32  14.5 Preprocessor1_Model1
 8  20.3 train/test split    37  20   Preprocessor1_Model1
 9  31.0 train/test split    41  34.9 Preprocessor1_Model1
10  23.6 train/test split    43  25.3 Preprocessor1_Model1
# ℹ 93 more rows

Analisando algumas predições acima do modelo KNN, observa-se que o modelo fez boas previsões para os preços médios (medv) em sua grande parte, porém para alguns preços médios o modelo não fez boas previsões.

# Extraindo o modelo KNN
modelo_final_knn <- 
  finalizando_knn %>% 
  extract_fit_parsnip()

# Fazendo previsões 
dados_novos <- dados[sample(1:nrow(dados), 10), ]

# Fazendo previsões com o modelo KNN
predict(finalizando_knn$.workflow[[1]], 
                           new_data = dados_novos) 

# A tibble: 10 × 1
   .pred
   <dbl>
 1  16.1
 2  23.0
 3  12.8
 4  28.0
 5  19.4
 6  13.4
 7  24.7
 8  34.1
 9  19.1
10  24.5

# Adicionando as previsões com o modelo KNN ao conjunto de dados original
previsoes_knn <- augment(finalizando_knn$.workflow[[1]], 
                         new_data = dados_novos) %>% print()

# A tibble: 10 × 16
   .pred .resid    crim    zn indus  chas   nox    rm   age   dis   rad   tax
   <dbl>  <dbl>   <dbl> <dbl> <dbl> <int> <dbl> <dbl> <dbl> <dbl> <int> <dbl>
 1  16.1 -0.475  4.10       0 19.6      0 0.871  5.47 100    1.41     5   403
 2  23.0  1.13   0.0790     0 12.8      0 0.437  6.27   6    4.25     5   398
 3  12.8 -1.07  13.9        0 18.1      0 0.713  6.21  95    2.22    24   666
 4  28.0 -4.05   0.0254    55  3.78     0 0.484  6.70  56.4  5.73     5   370
 5  19.4 -0.199  0.340      0 21.9      0 0.624  6.46  98.9  2.12     4   437
 6  13.4  1.47   9.51       0 18.1      0 0.713  6.73  94.1  2.50    24   666
 7  24.7  0.293  0.0288    28 15.0      0 0.464  6.21  28.9  3.67     4   270
 8  34.1 -0.957  0.0613    40  6.41     1 0.447  6.83  27.6  4.86     4   254
 9  19.1  0.742  0.245      0  9.9      0 0.544  5.78  71.7  4.03     4   304
10  24.5 -1.25   1.43       0 19.6      0 0.871  6.51 100    1.77     5   403
# ℹ 4 more variables: ptratio <dbl>, b <dbl>, lstat <dbl>, medv <dbl>

# Adicionando as previsões com o modelo KNN ao conjunto de dados original
previsoes_knn[, c("medv", ".pred")] %>% print()

# A tibble: 10 × 2
    medv .pred
   <dbl> <dbl>
 1  15.6  16.1
 2  24.1  23.0
 3  11.7  12.8
 4  23.9  28.0
 5  19.2  19.4
 6  14.9  13.4
 7  25    24.7
 8  33.1  34.1
 9  19.8  19.1
10  23.3  24.5

Observa-se que o modelo fez boas previsões para os preços médios (medv) em sua grande parte, porém para alguns preços médios o modelo não fez boas previsões.

Questão 4:

Com base na questão 1, escolha entre as 5 features preditoras que foram úteis para gerar \(y\), duas para introduzir \(10 \%\) de missing values em cada uma dessas duas variáveis. A introdução das observações faltantes deverá ser aleatória. Após, isso, realize a comparação do método Elastic-Net com o método K - Nearest Neighbors - KNN. Compare o risco preditivo de cada um do modelos. Na fase de pré-processamento, você deverá utilizar também o método KNN, considerando \(k =5\) dados faltantes. Qual o modelo que forneceu um melhor risco preditivo? Explique!

Resposta:

rm(list = ls())

# Carregando pacotes 
library(tidyverse)
library(tidymodels)
library(tibble)
library(purrr)
library(ggplot2)
library(patchwork)
library(workflowsets)
library(yardstick)
library(glmnet)
library(kknn)
library(visdat)

# Dando preferencias as funcoes do tidymodels 
tidymodels::tidymodels_prefer()

# Setando a semente 
set.seed(0)

# Função para gerar os dados 
gerando_dados <- function(n = 5000L){
  regressao <- function(i){
    x <- rnorm(n = 5000L, 0, 1)
    target <- 7*x[1L] - 5*x[2L] + 2*x[3L] + 4*x[4L] + 9*x[5L] + rnorm(1L, 0, 0.5)
    tibble(
      y = target,
      x1 = x[1L],
      x2 = x[2L],
      x3 = x[3L],
      x4 = x[4L],
      x5 = x[5L]
    )
  }
  dados <- purrr::map(.x = 1L:n, .f = regressao) %>% 
    purrr::list_rbind()
  
  parte_esparsa <- matrix(0, n, 15)
  
  dados <- cbind(dados, parte_esparsa)
  colnames(dados) <- c("y", paste0("x", 1L:20L))
  tibble::as_tibble(dados)
}

dados <- gerando_dados()

set.seed(0) 

# Introduzindo 10% missing values nas variáveis x3 e x5 de forma aleatória
id_na <- sample(1:nrow(dados), 0.1*nrow(dados))
dados[id_na, "x3"] <- NA
dados[id_na, "x5"] <- NA

# Olhando rapidamento os dados 
visdat::vis_dat(dados)

# Visualizando a correlação entre as variáveis
visdat::vis_cor(dados[-c(7:21)])

set.seed(0)

# Data Splitting
dados_split <- rsample::initial_split(dados, prop = 0.8, strata = "y")
treino <- rsample::training(dados_split)
teste <- rsample::testing(dados_split)

# Criando o conjunto de validação
cv <- rsample::vfold_cv(treino, v = 10L)

# Pré-processamento dos dados 
receita <- 
  recipe(y ~ ., data = treino) %>%
  # Eliminando as variáveis constantes (com zero variância)
  recipes::step_zv(all_predictors()) %>%
  # Normalizando as variáveis numéricas
  recipes::step_normalize(all_numeric_predictors()) %>%
  #considerando k = 5 para inputar os dados faltantes
  recipes::step_impute_knn(all_predictors(), neighbors = 5)  

# Setando o modelo (set engine) 
modelo_elastic <- 
  parsnip::linear_reg(penalty = tune::tune(), mixture = tune::tune()) %>% 
  parsnip::set_mode("regression") %>% 
  parsnip::set_engine("glmnet")

modelo_knn <- 
  parsnip::nearest_neighbor(neighbors = tune("k")) %>% 
  parsnip::set_mode("regression") %>% 
  parsnip::set_engine("kknn")

# Criando workflows 
all_wf <- 
  workflowsets::workflow_set(
    preproc = list(formula = receita),
    models = list(elastic = modelo_elastic, knn = modelo_knn), 
    cross = TRUE
  )

# Setando a métrica 
metrica <- yardstick::metric_set(rmse)

# Tunagem dos hiperparâmetros 
tunagem <- 
  all_wf %>% 
  workflowsets::workflow_map(
    seed = 0, 
    verbose = TRUE,
    resamples = cv,
    grid = 50,
    metrics = metrica
  )

i 1 of 2 tuning:     formula_elastic

✔ 1 of 2 tuning:     formula_elastic (1m 17.7s)

i 2 of 2 tuning:     formula_knn

✔ 2 of 2 tuning:     formula_knn (27.3s)

# Rank dos melhores modelos 
modelos_rank <- tunagem %>% workflowsets::rank_results() %>% print()

# A tibble: 65 × 9
   wflow_id        .config  .metric  mean std_err     n preprocessor model  rank
   <chr>           <chr>    <chr>   <dbl>   <dbl> <int> <chr>        <chr> <int>
 1 formula_elastic Preproc… rmse     3.29   0.162    10 recipe       line…     1
 2 formula_elastic Preproc… rmse     3.29   0.162    10 recipe       line…     2
 3 formula_elastic Preproc… rmse     3.29   0.162    10 recipe       line…     3
 4 formula_elastic Preproc… rmse     3.29   0.162    10 recipe       line…     4
 5 formula_elastic Preproc… rmse     3.29   0.162    10 recipe       line…     5
 6 formula_elastic Preproc… rmse     3.29   0.162    10 recipe       line…     6
 7 formula_elastic Preproc… rmse     3.29   0.162    10 recipe       line…     7
 8 formula_elastic Preproc… rmse     3.29   0.162    10 recipe       line…     8
 9 formula_elastic Preproc… rmse     3.29   0.162    10 recipe       line…     9
10 formula_elastic Preproc… rmse     3.29   0.162    10 recipe       line…    10
# ℹ 55 more rows

# Selecionando os melhores modelos 
melhor_elastic <- 
  tunagem %>% 
  workflowsets::extract_workflow_set_result("formula_elastic") %>% 
  tune::select_best(metric = "rmse")

melhor_knn <- 
  tunagem %>% 
  workflowsets::extract_workflow_set_result("formula_knn") %>% 
  tune::select_best(metric = "rmse")

# Finalizando os modelos 
finalizando_elastic <- 
  tunagem %>% 
  workflowsets::extract_workflow("formula_elastic") %>% 
  tune::finalize_workflow(melhor_elastic) %>% 
  tune::last_fit(split = dados_split)

finalizando_knn <-
  tunagem %>% 
  workflowsets::extract_workflow("formula_knn") %>% 
  tune::finalize_workflow(melhor_knn) %>% 
  tune::last_fit(split = dados_split)

# Visualizando as métricas do modelo Elastic Net
finalizando_elastic %>% workflowsets::collect_metrics()

# A tibble: 2 × 4
  .metric .estimator .estimate .config             
  <chr>   <chr>          <dbl> <chr>               
1 rmse    standard       3.41  Preprocessor1_Model1
2 rsq     standard       0.930 Preprocessor1_Model1

# Visualizando as métricas do modelo KNN
finalizando_knn %>% workflowsets::collect_metrics()

# A tibble: 2 × 4
  .metric .estimator .estimate .config             
  <chr>   <chr>          <dbl> <chr>               
1 rmse    standard       4.15  Preprocessor1_Model1
2 rsq     standard       0.906 Preprocessor1_Model1

Avaliando o risco preditivo dos modelos, nota-se que o modelo Elastic Net apresentou um Erro Quadrático Médio (EQM) de \(3.41\), enquanto o modelo KNN apresentou um EQM de \(4.15\). Além disso, observa-se que o modelo Elastic Net apresentou um \(R^{2}\) de \(0.930\), enquanto para o modelo KNN o \(R^{2}\) foi de \(0.906\). Como o EQM do modelo Elastic Net foi menor que o do modelo KNN, além do \(R^{2}\) do modelo Elastic Net ter sido maior que o do KNN, logo o modelo Elastic Net nos forneceu um melhor risco preditivo que o KNN.

# Visualizando predições do modelo Elastic Net
finalizando_elastic %>% workflowsets::collect_predictions()

# A tibble: 1,000 × 5
    .pred id                .row      y .config             
    <dbl> <chr>            <int>  <dbl> <chr>               
 1   7.87 train/test split     5   7.74 Preprocessor1_Model1
 2 -23.2  train/test split     7 -23.7  Preprocessor1_Model1
 3  -8.77 train/test split     9  -8.79 Preprocessor1_Model1
 4  -3.62 train/test split    19  -3.46 Preprocessor1_Model1
 5  -6.38 train/test split    22 -17.9  Preprocessor1_Model1
 6  -5.22 train/test split    24  -5.46 Preprocessor1_Model1
 7  10.8  train/test split    31  11.5  Preprocessor1_Model1
 8   4.62 train/test split    36   4.71 Preprocessor1_Model1
 9  -9.53 train/test split    37   3.42 Preprocessor1_Model1
10  19.4  train/test split    43  19.2  Preprocessor1_Model1
# ℹ 990 more rows

# Visualizando predições do modelo KNN
finalizando_knn %>% workflowsets::collect_predictions()

# A tibble: 1,000 × 5
    .pred id                .row      y .config             
    <dbl> <chr>            <int>  <dbl> <chr>               
 1   5.18 train/test split     5   7.74 Preprocessor1_Model1
 2 -17.5  train/test split     7 -23.7  Preprocessor1_Model1
 3 -10.2  train/test split     9  -8.79 Preprocessor1_Model1
 4  -2.10 train/test split    19  -3.46 Preprocessor1_Model1
 5  -4.44 train/test split    22 -17.9  Preprocessor1_Model1
 6  -4.17 train/test split    24  -5.46 Preprocessor1_Model1
 7  12.3  train/test split    31  11.5  Preprocessor1_Model1
 8   4.74 train/test split    36   4.71 Preprocessor1_Model1
 9  -5.85 train/test split    37   3.42 Preprocessor1_Model1
10  18.5  train/test split    43  19.2  Preprocessor1_Model1
# ℹ 990 more rows

# Extraindo o modelo Elastic Net
modelo_final_elastic <- 
  finalizando_elastic %>% 
  extract_fit_parsnip()

# Extraindo o modelo KNN
modelo_final_knn <- 
  finalizando_knn %>% 
  extract_fit_parsnip()

Questão 5:

Considere a base de dados referente à despesas médicas, cujo o objetivo é predizer a variável charges. Clique aqui para efetuar o download dos dados. Considere os algoritmos, lasso, ridge, elastic net e KNN e compare o risco preditivo de cada um dos modelos.

Você deverá utilizar boas práticas na comparação, explorar os dados e avaliar de forma adequada o risco preditivo de cada um dos modelos considerados. Perceba que existem variáveis categóricas na base de dados. Dessa forma, você deverá introduzir no pipeline o pré-processamento. Discuta o resultado.

Resposta:

rm(list = ls())

# Carregando pacotes 
library(tidyverse)
library(tidymodels)
library(tibble)
library(purrr)
library(ggplot2)
library(patchwork)
library(workflowsets)
library(yardstick)
library(glmnet)
library(kknn)
library(visdat)

# Dando preferencias as funcoes do tidymodels 
tidymodels::tidymodels_prefer()

# Setando a semente 
set.seed(0)

# Carregando os dados 
dados <- read.csv("~/JOANA/ESTATÍSTICA/2024.1/Aprendizagem de Máquina/AM/Prova2/dados/insurance.csv")

# Visualizando as primeiras observações dos dados
head(dados)

  age    sex    bmi children smoker    region   charges
1  19 female 27.900        0    yes southwest 16884.924
2  18   male 33.770        1     no southeast  1725.552
3  28   male 33.000        3     no southeast  4449.462
4  33   male 22.705        0     no northwest 21984.471
5  32   male 28.880        0     no northwest  3866.855
6  31 female 25.740        0     no southeast  3756.622

# Visualizando a estrutura dos dados
glimpse(dados)

Rows: 1,338
Columns: 7
$ age      <int> 19, 18, 28, 33, 32, 31, 46, 37, 37, 60, 25, 62, 23, 56, 27, 1…
$ sex      <chr> "female", "male", "male", "male", "male", "female", "female",…
$ bmi      <dbl> 27.900, 33.770, 33.000, 22.705, 28.880, 25.740, 33.440, 27.74…
$ children <int> 0, 1, 3, 0, 0, 0, 1, 3, 2, 0, 0, 0, 0, 0, 0, 1, 1, 0, 0, 0, 0…
$ smoker   <chr> "yes", "no", "no", "no", "no", "no", "no", "no", "no", "no", …
$ region   <chr> "southwest", "southeast", "southeast", "northwest", "northwes…
$ charges  <dbl> 16884.924, 1725.552, 4449.462, 21984.471, 3866.855, 3756.622,…

# Olhando rapidamento os dados 
visdat::vis_dat(dados)

# Visualizando a correlação entre as variáveis 
visdat::vis_cor(dados[-c(2,5,6)])

set.seed(0)

# Data Splitting
dados_split <- rsample::initial_split(dados, prop = 0.8, strata = "charges")
treino <- rsample::training(dados_split)
teste <- rsample::testing(dados_split)

# Criando o conjunto de validação
cv <- rsample::vfold_cv(treino, v = 5L)

# Pré-processamento dos dados 
receita <- 
  recipe(charges ~ ., data = treino) %>%
  # Eliminando as variáveis constantes (com zero variância)
  recipes::step_zv(all_predictors()) %>%
  # Normalizando as variáveis numéricas
  recipes::step_normalize(all_numeric_predictors()) %>%
  # Transformando as variáveis categóricas em dicotômicas (0 e 1) 
  step_dummy(all_nominal_predictors()) %>%
  # Eliminando as variáveis correlacionadas
  recipes::step_corr(all_numeric_predictors()) 

# Setando o modelo (set engine) 
modelo_ridge <- 
  parsnip::linear_reg(penalty = tune::tune(), mixture = 0) %>% 
  parsnip::set_mode("regression") %>% 
  parsnip::set_engine("glmnet")

modelo_lasso <- 
  parsnip::linear_reg(penalty = tune::tune(), mixture = 1) %>% 
  parsnip::set_mode("regression") %>% 
  parsnip::set_engine("glmnet")

modelo_elastic <- 
  parsnip::linear_reg(penalty = tune::tune(), mixture = tune::tune()) %>% 
  parsnip::set_mode("regression") %>% 
  parsnip::set_engine("glmnet")

modelo_knn <- 
  parsnip::nearest_neighbor(neighbors = tune("k")) %>% 
  parsnip::set_mode("regression") %>% 
  parsnip::set_engine("kknn")

# Criando workflows 
all_wf <- 
  workflowsets::workflow_set(
    preproc = list(formula = receita),
    models = list(ridge = modelo_ridge, lasso = modelo_lasso, 
                  elastic = modelo_elastic, knn = modelo_knn), 
    cross = TRUE
  )

# Setando a métrica 
metrica <- yardstick::metric_set(rmse)

# Tunagem dos hiperparâmetros 
tunagem <- 
  all_wf %>% 
  workflowsets::workflow_map(
    seed = 0, 
    verbose = TRUE,
    resamples = cv,
    grid = 50,
    metrics = metrica
  )

i 1 of 4 tuning:     formula_ridge

✔ 1 of 4 tuning:     formula_ridge (1.8s)

i 2 of 4 tuning:     formula_lasso

✔ 2 of 4 tuning:     formula_lasso (1.8s)

i 3 of 4 tuning:     formula_elastic

✔ 3 of 4 tuning:     formula_elastic (25s)

i 4 of 4 tuning:     formula_knn

✔ 4 of 4 tuning:     formula_knn (4.7s)

# Rank dos melhores modelos 
modelos_rank <- tunagem %>% workflowsets::rank_results() %>% print()

# A tibble: 165 × 9
   wflow_id    .config      .metric  mean std_err     n preprocessor model  rank
   <chr>       <chr>        <chr>   <dbl>   <dbl> <int> <chr>        <chr> <int>
 1 formula_knn Preprocesso… rmse    5363.    186.     5 recipe       near…     1
 2 formula_knn Preprocesso… rmse    5365.    190.     5 recipe       near…     2
 3 formula_knn Preprocesso… rmse    5366.    182.     5 recipe       near…     3
 4 formula_knn Preprocesso… rmse    5367.    194.     5 recipe       near…     4
 5 formula_knn Preprocesso… rmse    5370.    197.     5 recipe       near…     5
 6 formula_knn Preprocesso… rmse    5374.    176.     5 recipe       near…     6
 7 formula_knn Preprocesso… rmse    5388.    171.     5 recipe       near…     7
 8 formula_knn Preprocesso… rmse    5409.    166.     5 recipe       near…     8
 9 formula_knn Preprocesso… rmse    5437.    159.     5 recipe       near…     9
10 formula_knn Preprocesso… rmse    5471.    153.     5 recipe       near…    10
# ℹ 155 more rows

# Selecionando os melhores modelos 
melhor_ridge <- 
  tunagem %>% 
  workflowsets::extract_workflow_set_result("formula_ridge") %>% 
  tune::select_best(metric = "rmse")

melhor_lasso <- 
  tunagem %>% 
  workflowsets::extract_workflow_set_result("formula_lasso") %>% 
  tune::select_best(metric ="rmse")

melhor_elastic <- 
  tunagem %>% 
  workflowsets::extract_workflow_set_result("formula_elastic") %>% 
  tune::select_best(metric = "rmse")

melhor_knn <- 
  tunagem %>% 
  workflowsets::extract_workflow_set_result("formula_knn") %>% 
  tune::select_best(metric = "rmse")

# Finalizando os modelos 
finalizando_ridge <- 
  tunagem %>% 
  workflowsets::extract_workflow("formula_ridge") %>% 
  tune::finalize_workflow(melhor_ridge) %>% 
  tune::last_fit(split = dados_split)

finalizando_lasso <- 
  tunagem %>% 
  workflowsets::extract_workflow("formula_lasso") %>% 
  tune::finalize_workflow(melhor_lasso) %>% 
  tune::last_fit(split = dados_split)

finalizando_elastic <- 
  tunagem %>% 
  workflowsets::extract_workflow("formula_elastic") %>% 
  tune::finalize_workflow(melhor_elastic) %>% 
  tune::last_fit(split = dados_split)

finalizando_knn <-
  tunagem %>% 
  workflowsets::extract_workflow("formula_knn") %>% 
  tune::finalize_workflow(melhor_knn) %>% 
  tune::last_fit(split = dados_split)

# Visualizando as métricas do modelo Ridge
finalizando_ridge %>% workflowsets::collect_metrics()

# A tibble: 2 × 4
  .metric .estimator .estimate .config             
  <chr>   <chr>          <dbl> <chr>               
1 rmse    standard    6530.    Preprocessor1_Model1
2 rsq     standard       0.744 Preprocessor1_Model1

# Visualizando as métricas do modelo Lasso
finalizando_lasso %>% workflowsets::collect_metrics()

# A tibble: 2 × 4
  .metric .estimator .estimate .config             
  <chr>   <chr>          <dbl> <chr>               
1 rmse    standard    6442.    Preprocessor1_Model1
2 rsq     standard       0.743 Preprocessor1_Model1

# Visualizando as métricas do modelo Elastic Net
finalizando_elastic %>% workflowsets::collect_metrics()

# A tibble: 2 × 4
  .metric .estimator .estimate .config             
  <chr>   <chr>          <dbl> <chr>               
1 rmse    standard    6446.    Preprocessor1_Model1
2 rsq     standard       0.743 Preprocessor1_Model1

# Visualizando as métricas do modelo KNN
finalizando_knn %>% workflowsets::collect_metrics()

# A tibble: 2 × 4
  .metric .estimator .estimate .config             
  <chr>   <chr>          <dbl> <chr>               
1 rmse    standard    5550.    Preprocessor1_Model1
2 rsq     standard       0.811 Preprocessor1_Model1

Comparando o risco preditivo dos modelos, observa-se que o modelo KNN foi o que apresentou o melhor risco preditivo com um menor Erro Quadrático Médio (EQM) de \(5550\) e um maior \(R^{2}\) de \(0.811\). O modelo Lasso obteve um EQM de \(6442\), enquanto o modelo Elastic Net apresentou um EQM de \(6446\), em que ambos tiveram um \(R^{2}\) de \(0.743\). Por fim, o modelo que mostrou um pior desempenho foi o Ridge, com um maior EQM de \(6530\) e \(R^{2}\) de \(0.744\).

# Visualizando predições do modelo Ridge
finalizando_ridge %>% workflowsets::collect_predictions()

# A tibble: 268 × 5
    .pred id                .row charges .config             
    <dbl> <chr>            <int>   <dbl> <chr>               
 1  4479. train/test split     4  21984. Preprocessor1_Model1
 2  3903. train/test split    11   2721. Preprocessor1_Model1
 3 33465. train/test split    12  27809. Preprocessor1_Model1
 4  5090. train/test split    13   1827. Preprocessor1_Model1
 5  1604. train/test split    16   1837. Preprocessor1_Model1
 6  2688. train/test split    18   2395. Preprocessor1_Model1
 7  3690. train/test split    23   1137. Preprocessor1_Model1
 8  1027. train/test split    29   2775. Preprocessor1_Model1
 9 37300. train/test split    40  48173. Preprocessor1_Model1
10  7315. train/test split    48   3557. Preprocessor1_Model1
# ℹ 258 more rows

# Visualizando predições do modelo Lasso
finalizando_lasso %>% workflowsets::collect_predictions()

# A tibble: 268 × 5
     .pred id                .row charges .config             
     <dbl> <chr>            <int>   <dbl> <chr>               
 1  3809.  train/test split     4  21984. Preprocessor1_Model1
 2  3225.  train/test split    11   2721. Preprocessor1_Model1
 3 35034.  train/test split    12  27809. Preprocessor1_Model1
 4  4453.  train/test split    13   1827. Preprocessor1_Model1
 5   686.  train/test split    16   1837. Preprocessor1_Model1
 6  1921.  train/test split    18   2395. Preprocessor1_Model1
 7  2827.  train/test split    23   1137. Preprocessor1_Model1
 8    80.1 train/test split    29   2775. Preprocessor1_Model1
 9 39149.  train/test split    40  48173. Preprocessor1_Model1
10  6985.  train/test split    48   3557. Preprocessor1_Model1
# ℹ 258 more rows

# Visualizando predições do modelo Elastic Net
finalizando_elastic %>% workflowsets::collect_predictions()

# A tibble: 268 × 5
     .pred id                .row charges .config             
     <dbl> <chr>            <int>   <dbl> <chr>               
 1  3794.  train/test split     4  21984. Preprocessor1_Model1
 2  3271.  train/test split    11   2721. Preprocessor1_Model1
 3 34950.  train/test split    12  27809. Preprocessor1_Model1
 4  4453.  train/test split    13   1827. Preprocessor1_Model1
 5   688.  train/test split    16   1837. Preprocessor1_Model1
 6  1966.  train/test split    18   2395. Preprocessor1_Model1
 7  2834.  train/test split    23   1137. Preprocessor1_Model1
 8    73.2 train/test split    29   2775. Preprocessor1_Model1
 9 39060.  train/test split    40  48173. Preprocessor1_Model1
10  6989.  train/test split    48   3557. Preprocessor1_Model1
# ℹ 258 more rows

# Visualizando predições do modelo KNN
finalizando_knn %>% workflowsets::collect_predictions()

# A tibble: 268 × 5
    .pred id                .row charges .config             
    <dbl> <chr>            <int>   <dbl> <chr>               
 1  5659. train/test split     4  21984. Preprocessor1_Model1
 2  2511. train/test split    11   2721. Preprocessor1_Model1
 3 30708. train/test split    12  27809. Preprocessor1_Model1
 4  3901. train/test split    13   1827. Preprocessor1_Model1
 5  2186. train/test split    16   1837. Preprocessor1_Model1
 6  2038. train/test split    18   2395. Preprocessor1_Model1
 7  2203. train/test split    23   1137. Preprocessor1_Model1
 8  5770. train/test split    29   2775. Preprocessor1_Model1
 9 41128. train/test split    40  48173. Preprocessor1_Model1
10  2797. train/test split    48   3557. Preprocessor1_Model1
# ℹ 258 more rows

# Extraindo o modelo Ridge
modelo_final_ridge <- 
  finalizando_ridge %>% 
  extract_fit_parsnip()

# Extraindo o modelo Lasso
modelo_final_lasso <- 
  finalizando_lasso %>% 
  extract_fit_parsnip()

# Extraindo o modelo Elastic Net
modelo_final_elastic <- 
  finalizando_elastic %>% 
  extract_fit_parsnip()

# Extraindo o modelo KNN
modelo_final_knn <- 
  finalizando_knn %>% 
  extract_fit_parsnip()

# Fazendo previsões 
dados_novos <- dados[sample(1:nrow(dados), 10), -7]

# Fazendo previsões com o modelo Ridge
predict(finalizando_ridge$.workflow[[1]], 
                           new_data = dados_novos)

# A tibble: 10 × 1
    .pred
    <dbl>
 1 13401.
 2 11853.
 3 31753.
 4  2863.
 5 14363.
 6  2359.
 7 33426.
 8 36616.
 9 16854.
10 12328.

# Fazendo previsões com o modelo Lasso
predict(finalizando_lasso$.workflow[[1]], 
                           new_data = dados_novos)

# A tibble: 10 × 1
    .pred
    <dbl>
 1 13368.
 2 11880.
 3 33127.
 4  2067.
 5 14574.
 6  1522.
 7 34993.
 8 38380.
 9 17129.
10 12357.

# Fazendo previsões com o modelo Elastic Net
predict(finalizando_elastic$.workflow[[1]], 
                           new_data = dados_novos)

# A tibble: 10 × 1
    .pred
    <dbl>
 1 13354.
 2 11915.
 3 33086.
 4  2077.
 5 14615.
 6  1520.
 7 34914.
 8 38308.
 9 17150.
10 12339.

# Fazendo previsões com o modelo KNN
predict(finalizando_knn$.workflow[[1]], 
                           new_data = dados_novos)

# A tibble: 10 × 1
    .pred
    <dbl>
 1 14898.
 2 12985.
 3 39307.
 4  2830.
 5 12436.
 6  3172.
 7 34266.
 8 43150.
 9 11881.
10 15496.

# Adicionando as previsões com o modelo Ridge ao conjunto de dados original
augment(finalizando_ridge$.workflow[[1]], 
                         new_data = dados_novos)

# A tibble: 10 × 7
    .pred   age sex      bmi children smoker region   
    <dbl> <int> <chr>  <dbl>    <int> <chr>  <chr>    
 1 13401.    55 male    37.3        0 no     southwest
 2 11853.    63 female  23.1        0 no     northeast
 3 31753.    30 female  39.0        3 yes    southeast
 4  2863.    22 female  28.0        0 no     southeast
 5 14363.    62 female  31.7        0 no     northeast
 6  2359.    19 male    28.7        0 no     southwest
 7 33426.    57 female  29.8        0 yes    southeast
 8 36616.    48 male    40.6        2 yes    northwest
 9 16854.    52 female  44.7        3 no     southwest
10 12328.    63 female  25.1        0 no     northwest

# Adicionando as previsões com o modelo Lasso ao conjunto de dados original
augment(finalizando_lasso$.workflow[[1]], 
                         new_data = dados_novos)

# A tibble: 10 × 7
    .pred   age sex      bmi children smoker region   
    <dbl> <int> <chr>  <dbl>    <int> <chr>  <chr>    
 1 13368.    55 male    37.3        0 no     southwest
 2 11880.    63 female  23.1        0 no     northeast
 3 33127.    30 female  39.0        3 yes    southeast
 4  2067.    22 female  28.0        0 no     southeast
 5 14574.    62 female  31.7        0 no     northeast
 6  1522.    19 male    28.7        0 no     southwest
 7 34993.    57 female  29.8        0 yes    southeast
 8 38380.    48 male    40.6        2 yes    northwest
 9 17129.    52 female  44.7        3 no     southwest
10 12357.    63 female  25.1        0 no     northwest

# Adicionando as previsões com o modelo Elastic Net ao conjunto de dados original
augment(finalizando_elastic$.workflow[[1]], 
                         new_data = dados_novos)

# A tibble: 10 × 7
    .pred   age sex      bmi children smoker region   
    <dbl> <int> <chr>  <dbl>    <int> <chr>  <chr>    
 1 13354.    55 male    37.3        0 no     southwest
 2 11915.    63 female  23.1        0 no     northeast
 3 33086.    30 female  39.0        3 yes    southeast
 4  2077.    22 female  28.0        0 no     southeast
 5 14615.    62 female  31.7        0 no     northeast
 6  1520.    19 male    28.7        0 no     southwest
 7 34914.    57 female  29.8        0 yes    southeast
 8 38308.    48 male    40.6        2 yes    northwest
 9 17150.    52 female  44.7        3 no     southwest
10 12339.    63 female  25.1        0 no     northwest

# Adicionando as previsões com o modelo KNN ao conjunto de dados original
augment(finalizando_knn$.workflow[[1]], 
                         new_data = dados_novos)

# A tibble: 10 × 7
    .pred   age sex      bmi children smoker region   
    <dbl> <int> <chr>  <dbl>    <int> <chr>  <chr>    
 1 14898.    55 male    37.3        0 no     southwest
 2 12985.    63 female  23.1        0 no     northeast
 3 39307.    30 female  39.0        3 yes    southeast
 4  2830.    22 female  28.0        0 no     southeast
 5 12436.    62 female  31.7        0 no     northeast
 6  3172.    19 male    28.7        0 no     southwest
 7 34266.    57 female  29.8        0 yes    southeast
 8 43150.    48 male    40.6        2 yes    northwest
 9 11881.    52 female  44.7        3 no     southwest
10 15496.    63 female  25.1        0 no     northwest